home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
WAFPEGTP
/
MAKEUSE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-01-16
|
13KB
|
486 lines
{$A+,B-,D-,E-,F-,I+,L-,N-,O-,R+,S+,V-}
{$M 16384,0,10000}
program makeuse;
{
pull all names from bindery
and write waffle user dir's
rml
april 1992
Copyright (C) 1992 Dr Ross Lazarus
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
Dr Ross Lazarus is the original copyright holder of this code.
Email: rossl@gmu.wh.su.edu.au
Mail: Department of Community Medicine,
Westmead Hospital
Westmead, NSW 2145
Australia
Fax: (+61 2) 689 1049
+ cleaned up January 1994 for public release of code
+ 2/oct 1992 fixed bug to not make a directory for the smartass blank
name that isd insists on putting into the bindery ! Ah, but it's actually
chr(255) the sneaky bastards...
}
uses dos, crt, novell;
const
wuser : string = 'f:\waffle\user';
copyright = 'Copyright (C) Dr Ross Lazarus, August 1992';
copyright2 = 'All rights reserved. Unauthorised use and distribution prohibited';
debug : boolean = false;
some : boolean = false;
prog = 'Makeuse';
ver = '0.04, 94.01.16';
waffleset = 'WAFFLE';
userdirtag = 'USER:';
hosttag = 'NODE:';
wafdir : string = '\waffle\system\static';
progname = 'Makeuse - Netware Bindery -> Waffle User converter';
version = 'Version ' + ver + ', rossl@gmu.wh.su.edu.au';
var
retcode : integer;
{ scan object variables }
lastseen : longint;
object_type : integer;
object_name : string;
replyid : longint;
replytype : integer;
replyname : string;
replyflag : integer;
replysecurity : byte;
dummy,replyproperties : integer;
home,hostname : string;
givehelp : boolean;
function mirt(trime : String) : String;
{ trim all blanks }
const
blank = ' ';
var
l : integer;
t : string;
begin
t := '';
for l := 1 to length(trime) do
if (trime[l] <> blank) then
t := t + trime[l];
mirt := t;
end; { mirt }
Procedure explainuse;
{
chide
and halt
}
begin
writeln('MAKEUSE - makes a Waffle/User subdirectory for each user in the');
writeln('Netware bindery so they can legally receive mail via Waffle.');
writeln('Waffle static file path must be available as a DOS environment');
writeln('variable called WAFFLE - waffle user: directory will be used.');
writeln('Alternatively, a path may be provided as a parameter to the directory');
writeln('below which user directories will be created - eg makeuse f:\home');
writeln('This should be run regularly so that new users created by the');
writeln('supervisor can automatically receive mail from the WafPeg Pmail UDG');
writeln('Copy and distribute without payment only !!');
writeln('Copyright (C) August 1992, Dr Ross Lazarus');
writeln('Enquiries: rossl@gmu.wh.su.edu.au');
halt(1);
end;
function exists(fn : string) : boolean;
{
return true if fn is a file name
}
var
s : searchrec;
begin
{$i-}
findfirst(fn,anyfile,s);
exists := (doserror = 0) ;
{$i+}
end;
procedure listusers;
{
make a list of the current object type
}
var
newdir : string;
dummy : integer;
begin
retcode := 0;
lastseen := -1;
object_type := 1;
object_name := '*';
while (retcode = 0) do
begin
scan_object(lastseen, object_type, object_name,
replyid, replytype, replyname, replyflag, replysecurity,
replyproperties, retcode);
replyname := mirt(replyname);
if (retcode = 0) and (mirt(replyname) > ' ') then
begin
newdir := wuser + '\' + copy(replyname,1,8);
if not exists(newdir) then
begin
{$i-}
mkdir(newdir);
dummy := ioresult;
{$i+}
if dummy <> 0 then
writeln('Unable to create ',newdir)
else
begin
if not some then
some := true;
writeln('New user added - ',newdir,' made');
end;
end; { make new }
end; { retcode = 0 }
lastseen := replyid;
end; { scan bindery }
end; { listusers }
procedure dolist;
{
do the work
}
var
thingval : byte;
status : integer;
begin
object_type := 1;
object_name := '*';
listusers;
case retcode of
$00:;
$96: writeln('Failure - retcode = server out of memory');
$ef: writeln('Failure - retcode = Invalid name');
$fe: writeln('Failure - bindery locked ');
$fe: writeln('Failure - bindery failure - try bindfix');
end;
end;
function UpcaseStr(S : String) : String;
(* converts a string to upper case *)
var
P : Integer;
begin
for P := 1 to Length(S) do
S[P] := Upcase(S[P]);
UpcaseStr := S;
end; { Upcasestr }
function before(sep : string ; s : string) : string;
{
return characters up to sep in s
if no sep, return whole of s
}
var
i : integer;
begin
i := pos(sep,s);
if (i = 0) then
before := s
else
before := copy(s,1,pred(i));
end;
function after(sep :string ; var s : string) : string;
{
return characters after sep in s
if no sep, returns null string
}
var
i,j,l : integer;
begin
l := length(s);
j := length(sep);
i := pos(sep,s);
while (copy(s,i+j,j) = sep) and (i < l) do
inc(i,j);
if (i = 0) or (i >= l) then
after := ''
else
after := copy(s,i + j,999);
end; { after }
{---------------- date and time support ------------------}
const
daypos = 1;
monthpos = 3;
Limit : Array[1..13] of Integer = (31,29,31,30,31,30,31,31,30,31,30,31,31);
MthTab : Array[1..12] of String[9] = ('Jan','Feb','Mar',
'Apr','May','Jun','Jul',
'Aug','Sep','Oct',
'Nov','Dec');
DayTab : Array[0..6] of String[9] = ('Sun','Mon','Tue',
'Wed','Thu','Fri',
'Sat');
Function SysTime : String;
Var
H, M, S : String[2];
hh,mm,ss,s100 : word;
Begin
gettime(hh,mm,ss,s100);
Str(hh:2, H);
Str(mm:2, M);
Str(ss:2, S);
if H[1] = ' ' then H[1] := '0';
if M[1] = ' ' then M[1] := '0';
if S[1] = ' ' then S[1] := '0';
SysTime := H + ':' + M + ':' + S
End;
Function rfc822date : String;
Var
I : Integer;
S1,S2,today : String[30];
dd,mm,yy,d,hh,ss,s100 : word;
ds : string[2];
ys : string[4];
status,mn : integer;
Begin
getdate(yy,mm,dd,d);
str(dd,ds);
str(yy,ys);
S1 := daytab[D]+', ' + mirt(ds) + ' ' + mthtab[mm] + ' ' + ys;
rfc822Date:= s1 + ' ' + systime;
End;
function findwuserdir : string;
{
find waffle static file from environmental variable
and read to locate user dir
}
var
infile : text;
wuserdir,tmpstring : string;
uppers : string;
ufound,hfound : boolean;
c : char;
function find(id,usource,source : string; var dest : string) : boolean;
{
seek id in the source string
if found, return whatever starts with the first alphabetic character
after the id label
}
var
temps : string;
function alphaafter(sep,ups,s : string ) : string;
{
return first alpha characters after sep in s
if no sep, returns null string
uses uppercase version of sep and s to find substring
}
const alpha : set of char = ['0'..'9','A'..'z'];
var
i,j,l : integer;
rets : string;
begin { alphaafter }
sep := upcasestr(sep);
rets := '';
l := length(s);
j := length(sep);
i := pos(sep,ups);
if (i <> 0) then
begin
i := i + j;
while not (ups[i] in alpha) and (i < l) do
inc(i);
if (i > 0) and (i <= l) then
rets := copy(s,i,l);
end; { not there }
alphaafter := rets;
end; { alphaafter }
begin { find }
if (pos(id,usource) <> 0) then
begin
dest := '';
temps := alphaafter(id,usource,source);
if (temps = '') then
begin
writeln(systime,' No ',id,' specified in ',wafdir);
halt(1);
end
else
begin
dest := temps;
find := true;
end;
end { leave dest alone if id not found }
else
find := false;
end; { find }
begin { findwuserdir }
(*
* Waffle uses an environment variable (WAFFLE) to point at the
* static parameters file
*)
hfound := false;
ufound := false;
hostname := '?(NODE: not found in Waffle static file)';
wafdir := getenv(waffleset);
if (wafdir = '') then
begin
writeln(systime, ' ERROR: WAFFLE environment variable has not been defined');
writeln('PLEASE read the Waffle DOS documentation !!!');
writeln(systime,' halting abnormally - dos error code set to 1');
halt(1);
end;
{$i-}
assign(infile,wafdir);
reset(infile);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
begin
writeln(systime ,' ERROR: Waffle static file ',wafdir,' cannot be opened');
writeln(systime, ' halting abnormally - dos error code set to 2');
halt(2);
end;
while not (hfound and ufound) and not eof(infile) do
begin
readln(infile,tmpstring);
if (tmpstring[1] <> ';') and (tmpstring[1] <> '#') and (tmpstring > '') then
begin
tmpstring := mirt(tmpstring);
uppers := upcasestr(tmpstring);
if not ufound then
ufound := find(userdirtag,uppers,tmpstring,wuserdir);
if not hfound then
hfound := find(hosttag,uppers,tmpstring,hostname);
end;
end; { eof }
close(infile);
if (wuserdir = '') then
begin
writeln(systime ,' ERROR: No USER directory in Waffle Static file ',wafdir);
writeln('Using \waffle\user as default');
wuserdir := '\waffle\user';
end;
findwuserdir := wuserdir;
end; {findwuserdir }
begin { main }
getdir(0,home);
assign(input,''); { enable redirection of log output }
reset(input);
assign(output,'');
rewrite(output);
writeln('| ');
writeln(progname,' ',rfc822date);
writeln(version);
if (pos('ß',ver) <> 0) then
begin
writeln(copyright);
writeln(copyright2);
writeln('This is a BETA TEST VERSION - please do not distribute !!!');
end;
givehelp := (pos('?',paramstr(1)) <> 0);
if not givehelp and (paramcount > 0) then
begin
{$i-}
wuser := paramstr(1);
chdir(wuser);
{$i-}
dummy := ioresult;
if (dummy <> 0) then
begin
writeln('ERROR - cannot change to ',wuser);
givehelp := true;
wuser := '';
end;
end
else
wuser := findwuserdir;
if (wuser = '') or givehelp then
explainuse;
if not apiavailable then
begin
writeln(systime,' No sign of a Novell Netware network. Sorry, can''t help you');
halt(1);
end;
{$i-}
chdir(wuser);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
begin
writeln(systime,' ERROR - Cannot find ',wuser);
writeln(systime,' Terminating with dos error code set to 8');
{$i-}
chdir(home);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
writeln(systime,' Error - cannot return to homedir ',home);
halt(8);
end;
getserverinfo;
dolist;
{$i-}
chdir(home);
{$i+}
dummy := ioresult;
if (dummy <> 0) then
writeln(systime,' Error - cannot return to homedir ',home);
if not some then
writeln(systime,' ho hum, nothing to do. No new users found in Bindery.');
close(output);
end.
{
makeuse.pas
rml august 1992
}